home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / EVAL._c < prev    next >
Text File  |  1990-12-08  |  28KB  |  956 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include <setjmp.h>
  18.  
  19. #include "systems.h"
  20. #include "types.h"
  21. #include "errors.h"
  22. #include "atoms.h"
  23. #include "files.h"
  24.  
  25. /*
  26.  
  27. EVALUABLE PREDICATES
  28.  
  29. */
  30.  
  31.  
  32. IMPORT int BCT ;               /* from execute.c       */
  33. IMPORT ATOM GetAtom();          /* from atomtable.c     */
  34. IMPORT boolean INTRES();        /* from unify.c         */
  35. IMPORT ENV NEWENV();            /* from unify.c         */
  36. IMPORT void KILLSTACKS();       /* from unify.c         */
  37. IMPORT boolean DOFASSIGN();
  38. IMPORT void DOABOLISH();        /* from retract.c       */
  39. IMPORT boolean FERRORFLAG;      /* from files.c         */
  40. #ifdef ARCHY
  41. IMPORT boolean SYNCLFLAG;       /* from io.c */
  42. #endif
  43. IMPORT boolean ECHOFLAG,HALTFLAG,OCHECK;
  44. IMPORT boolean WARNFLAG,TRACING,SPYTRACE;
  45. IMPORT boolean aSYSMODE,REDUCEFLAG;
  46. IMPORT boolean ENAB_INTR;
  47. IMPORT int SPYING;
  48. IMPORT ENV E;
  49. IMPORT ENV CHOICEPOINT;  /* from execute.c       */
  50. IMPORT void DOVERSION();
  51. IMPORT void DOOP();             /* from atomtabl.c      */
  52. IMPORT void ARGERROR(),ERROR(),ABORT(),SYSTEMERROR(); /* from linebufffer.c */
  53. IMPORT void REGET();
  54. IMPORT file OpenFile();        /* from files.c */
  55. IMPORT void CloseFile();     
  56. IMPORT void LISTOUT();         /* from writeout.c */
  57. IMPORT void DOPUT(),DOCLS();   /* from inout.c */
  58. IMPORT void DOGOTOXY(),DOTAB(),DOSKIP();
  59. IMPORT ENV TRACE_GOON;           /* from writeout.c      */
  60. IMPORT void DOPRIVATE(),DOHIDE();
  61. IMPORT void DOASSERT(),DOASSA();          /* from assert.c        */
  62. IMPORT boolean DOANCESTORS(),DOAPPEND(),DOMEMBER();
  63. IMPORT boolean DOSAVE();
  64. IMPORT void STARTATOM(),ATOMCHAR();
  65. IMPORT string NEWATOM;
  66. IMPORT boolean EVENT;
  67. IMPORT jmp_buf error_label;              /* from prolog.c        */
  68. IMPORT int ERRORFLAG;           /* the current error no if any */
  69. IMPORT boolean RES;
  70. IMPORT ATOM LOOKUP(),LOOKATOM(),copyatom(),atom();
  71. IMPORT boolean CallUser();               /* from usereval.c */
  72. IMPORT boolean DOCONSULT();
  73. IMPORT boolean xWINDOW_ON;
  74. IMPORT void wq();
  75. IMPORT TERM READIN();
  76. IMPORT boolean DOTIME(),DOTIMER(),DOGET0(),DOGET(),DOASK();
  77. IMPORT boolean DOSEE(), DOSEEN(), DOTELL(),DOOPEN(),DOCLOSE();
  78. IMPORT boolean DOREAD();
  79. IMPORT boolean LINEENDED(),FILEENDED(),DONAME(),DOIS();
  80. IMPORT boolean DOACOMP(),DODASS(),DOREDUCE(),DOCLAUSE();
  81. IMPORT boolean DORETRACT(),DOENSURE(),DOSEEK();
  82. IMPORT boolean DOPEEK(),DOPOKE();
  83. IMPORT boolean islist();
  84. IMPORT boolean UserAbort;
  85. IMPORT void ws(),WRITEOUT(),DISPLAY(),LONG_JMP();
  86. IMPORT boolean UNIFY();
  87. IMPORT int INTVALUE();
  88. #if WINDOWS
  89. IMPORT char t_rc();
  90. #endif
  91. #if DBASE3
  92. IMPORT boolean DOOPENDBF(),DOCLOSEDBF(),DOREADDBF();
  93. IMPORT boolean DOWRITEDBF(),DOSEEKDBF(),DOERASEDBF();
  94. #endif
  95. IMPORT void setinfile(),setoutfile(),getinfile(),DOSTATS(),getoutfile();
  96. IMPORT int ARGC;
  97. IMPORT char **ARGV;
  98. IMPORT TERM HEAPTOP,GLOTOP;
  99. IMPORT ATOM ATOMSTOP,ATOMHTOP;
  100. IMPORT ENV ENVTOP;
  101. IMPORT TRAIL TRAILEND;
  102. IMPORT int RETURN_CODE;
  103.  
  104. #if SYMBOLARITH
  105. IMPORT TERM SUBSTITUTION();
  106. #endif
  107.  
  108. #if !CPM
  109. #if !RISCOS
  110. IMPORT putenv();
  111. #endif
  112. IMPORT char *getenv();
  113. IMPORT boolean call_system();            /* from systems.c       */
  114. #endif
  115.  
  116. TERM A0,A1,A2,A3;            /* global Arguments for all evaluable p. */
  117.  
  118. #define set_spytrace()   {if(SPYTRACE= (SPYING || TRACING))EVENT=true;}
  119.  
  120. GLOBAL void CHECKATOM(register TERM A)
  121. { if(name(A)<NORMATOM || arity(name(A))) ARGERROR();
  122. }
  123.  
  124. GLOBAL boolean isatom(register TERM T)
  125. { return name(T)>=NORMATOM && arity(name(T))==0; }
  126.  
  127. GLOBAL void TESTATOM(register ATOM A, register TERM T)
  128. { if(name(T)!=A) ARGERROR(); }
  129.  
  130. #if !CPM
  131. LOCAL boolean DOGETENV(void)
  132. {
  133.     register char *envp;
  134.     CHECKATOM(A1);
  135.     if(envp=getenv(tempcopy(name(A1))))
  136.     return UNI(A0,mkatom(LOOKUP(envp,0,false)));
  137.     else return false;
  138. }
  139. #if !P8000 && !RISCOS
  140. LOCAL void DOPUTENV(void)
  141. {
  142.     if(isatom(A0) && isatom(A1))
  143.     {
  144.         register char *s;
  145.         STARTATOM();
  146.         s=tempcopy(name(A0)); while(*s)ATOMCHAR(*s++);
  147.         ATOMCHAR('=');
  148.         s=tempcopy(name(A1)); while(*s)ATOMCHAR(*s++);
  149.         ATOMCHAR('\0');
  150.         putenv(NEWATOM); /* -- problematisch -- md */
  151.     }
  152.     else ARGERROR();
  153. }
  154. #endif
  155. #endif
  156.  
  157.  
  158. LOCAL boolean DODICT(boolean SYSTEM)
  159. { 
  160.     register ATOM A=nil_atom;
  161.     register TERM T=nil_term;
  162.     for (A=GetAtom(nil_atom);non_nil_atom(A);A=GetAtom(A))
  163.     {   
  164.         register TERM Q; 
  165.         if((system(A) && !SYSTEM) || (SYSTEM && !system(A)))
  166.             continue;
  167.         Q=mk2sons(LOOKATOM(A,0),nil_term,INTT,(TERM)arity(A));
  168.         if(non_nil_term(T)) T=mk2sons(DIVIDE_2,Q,CONS_2,T);
  169.         else T=mk2sons(DIVIDE_2,Q,NIL_0,nil_term);
  170.     }
  171.     if(non_nil_term(T)) return UNI(A0,mkfunc(CONS_2,T));
  172.     return UNI(A0,mkatom(NIL_0));
  173. }
  174.  
  175. LOCAL int compare( TERM A,  TERM B, int DEPTH)
  176. { 
  177.     int N;
  178.     ATOM AA,BB;
  179. #if REALARITH
  180.     REAL R;
  181. #endif
  182. #if LONGARITH
  183.     LONG L;
  184. #endif
  185.     int i,aar;
  186. #if REALARITH
  187. #define realret(expr) { R=expr; if(R < (REAL)0) return -1;\
  188.                                 else return  (R > (REAL)0); \
  189.                        }
  190. #endif   
  191. #if LONGARITH
  192. #define longret(expr) { L=expr; if(L < (LONG)0) return -1;\
  193.                                 else return  (L > (LONG)0); \
  194.                        }   
  195. #endif
  196.     if(DEPTH <=0) ABORT(DEPTHE);
  197.     deref(A); deref(B);
  198.     if((AA=name(A))==UNBOUNDT)
  199.         if(name(B)==UNBOUNDT) 
  200.             return 0;
  201.         else return -1;
  202.     else if(AA >=NORMATOM)
  203.     { STRING AIDX,BIDX; char CA,CB;
  204.         if((BB=name(B)) < NORMATOM) return 1;
  205.         AIDX=longstring(AA); BIDX=longstring(BB);
  206.         for(;;) 
  207.          { CA=repchar(AIDX); CB=repchar(BIDX);
  208.            if(CA || CB)
  209.              if(CA==CB) { AIDX++; BIDX++; continue; }
  210.              else return CA-CB;
  211.            else break;
  212.          }   
  213.         aar=arity(name(A)); /*==arity(name(B)) */
  214.         A=son(A); B=son(B);
  215.         N = 0;
  216.         for(i=0;i < aar && ((N=compare(A,B,DEPTH-1))==0) ; i++)
  217.         { 
  218.             next_br(A);next_br(B);
  219.         }
  220.         if(N) return N;
  221.         if(A) 
  222.             if(B) return 0; 
  223.             else return 1;
  224.         else 
  225.             if(B) return -1; 
  226.             else return 0;
  227.     }
  228.     else if(AA==INTT )
  229.     {
  230.         if((BB=name(B))==UNBOUNDT) return 1;
  231.         if(BB==INTT) return ival(A)-ival(B);
  232. #if LONGARITH
  233.         else if(BB==LONGT){longret(ival(A)-longval(B));}
  234. #endif
  235. #if REALARITH
  236.         else if(BB==REALT){realret(ival(A)-realval(B));} 
  237. #endif
  238.         else return -1;
  239.     }
  240. #if LONGARITH
  241.     else if(AA==LONGT)
  242.     {
  243.         if((BB=name(B))==UNBOUNDT) return 1;
  244.         else if(BB==INTT) {longret(longval(A)-ival(B));}
  245.         else if(BB==LONGT){longret(longval(A)-longval(B));}
  246. #if REALARITH
  247.         else if(BB==REALT){realret(longval(A)-realval(B));} 
  248. #endif
  249.         else return -1;
  250.     }
  251. #endif
  252. #if REALARITH
  253.     else if(AA==REALT )
  254.     {
  255.         if((BB=name(B))==UNBOUNDT) return 1;
  256.         else if(BB==INTT) {realret(realval(A)-ival(B));}
  257. #if LONGARITH
  258.         else if(BB==LONGT){realret(realval(A)-longval(B));}
  259. #endif
  260.         else if(BB==REALT){realret(realval(A)-realval(B));} 
  261.         else return -1;
  262.     }
  263. #endif
  264.     else SYSTEMERROR("compare");        
  265. #if REALARITH
  266. #undef realret
  267. #endif
  268. #undef longret
  269.   return 0; /* never reached, keeps lint silent */
  270. }
  271.  
  272.  
  273. LOCAL boolean DOFUNCTOR (void)
  274. { 
  275.     TERM  X, Y;
  276.     ATOM A;
  277.     int  I, M;
  278.   
  279.     A=name(A0); 
  280.     if(is_number(A)) 
  281.             return UNI(A0,A1) && INTRES(A2,0);
  282.     if(A==UNBOUNDT)
  283.       { M=INTVALUE(A2);
  284.         if(isatom(A1) && M>=0)
  285.           { X=Y=stackterms(M);
  286.             for(I=0;I<M;I++)
  287.               { name(X)=UNBOUNDT; son(X)=nil_term; next_br(X);}
  288.             return UNI(A0,mkfunc(LOOKATOM(name(A1),M),Y)); 
  289.           }
  290.         if(name(A1)==INTT && M==0) 
  291.             return INTRES(A0,ival(A1));
  292.         if((name(A1)==REALT || name(A1)==LONGT) && M==0)
  293.             return UNI(A0,A1);
  294.         ARGERROR();
  295.       }     
  296.     return INTRES(A2,(int)arity(A)) && UNI(A1,mkatom(LOOKATOM(A,0)));
  297. }
  298.  
  299. LOCAL boolean DOARG (void)
  300. { 
  301.     register TERM  X;
  302.     register int  I, N;
  303.     
  304.     if(name(A0)!=INTT || name(A1)< NORMATOM ) ABORT(ARGE);
  305.     N= (int)ival(A0);
  306.     if(N<1 || N> arity(name(A1))) 
  307.         ABORT(ARGE);
  308.     X=son(A1);
  309.     for(I=2; I<=N; ++I) next_br(X);
  310.     return UNI(A2,X);
  311. }
  312.  
  313. LOCAL int LISTATOM(ATOM A)
  314. { 
  315.     register CLAUSE CL; register TERM X; int N=0;
  316.   
  317.     if(class(A) !=NORMP) return 0;
  318.     if((system(A) || hide(A) || private(A)) && !DEBUGFLAG) return 0;
  319.     if(A==REPEAT_0) return 0;
  320. /*    if(*tempcopy(A)== '$' && !DEBUGFLAG) return 0; */
  321.     for(CL=clause(A);non_nil_clause(CL);CL=nextcl(CL))
  322.     { 
  323.         LISTOUT(head(CL));
  324.         if(name(X=body(CL)))
  325.         {   register notfirst =0;
  326.             ws(":-");
  327.             for(;;) 
  328.             { 
  329.                 while(name(X)==GOTO_1) X=son(X);
  330.                 if(name(X)==nil_atom) break;
  331.                 if(notfirst++) ws(",");
  332.                 ws("\n    ");LISTOUT(X);next_br(X);
  333.                 if(UserAbort) return(N);
  334.             }
  335.         }
  336.         ws(".\n");
  337.         N++;
  338.         if(UserAbort) return(N);
  339.     }
  340.     return N;
  341. }
  342.  
  343. LOCAL void DOLISTING(void)
  344. { 
  345.     ATOM A,AA;
  346.     int N=0,i;
  347.   
  348.     if(isatom(A0))
  349.     {
  350.         if(name(A0)!=ALL_0 )
  351.         {   A=name(A0);
  352.             for(i=0;i<MAXARITY;++i)
  353.             { AA=LOOKATOM(A,-i);
  354.               if(non_nil_atom(AA) && isheapatom(AA)) N +=LISTATOM(AA);
  355.             }
  356.             if(WARNFLAG && N==0 )
  357.             { ws("WARNING: no clause for relation ");
  358.               wq(name(A0)); ws("\n"); 
  359.             }
  360.         }
  361.         else 
  362.         { /* name(A0)==ALL_0 */
  363.           for(A=GetAtom(nil_atom);non_nil_atom(A);A=GetAtom(A)) 
  364.             N+=LISTATOM(A); 
  365.         }
  366.     }
  367.     else 
  368.     { 
  369.         /* ! isatom(A0) */
  370.         if(non_nil_atom(A=atom(A0))) 
  371.             if(non_nil_atom(A) && isheapatom(A)) N+=LISTATOM(A); 
  372.         if(WARNFLAG && N==0)
  373.         {
  374.             ws("WARNING: no clause for relation ");
  375.             wq(A);ws("/");wi(arity(A)); ws("\n"); 
  376.         } 
  377.     } 
  378. }
  379.  
  380.  
  381. LOCAL void DOSPY(boolean SPYMODE)
  382. { 
  383.     ATOM A;
  384.     int i;
  385.     if(isatom(A0)) 
  386.         if(name(A0) !=ALL_0)
  387.             for(i=0;i<=MAXARITY;i++)
  388.             {
  389.                 A=LOOKATOM(name(A0),-i);
  390.                 if(non_nil_atom(A)) 
  391.                 {
  392.                     A=copyatom(A);
  393.                     if(!spy(A) && SPYMODE) SPYING++;
  394.                     if(spy(A) && !SPYMODE) SPYING--;
  395.                     if(SPYMODE) setspy(A); else setnotspy(A);
  396.                 }
  397.             }
  398.         else /* name(A0)==ALL_0 */
  399.         {
  400.             for(A=GetAtom(nil_atom);non_nil_atom(A);A=GetAtom(A))
  401.             {
  402.                 if(!spy(A) && SPYMODE) SPYING++;
  403.                 if(spy(A) && !SPYMODE) SPYING--;
  404.                 if(SPYMODE) setspy(A); else setnotspy(A);
  405.             }
  406.         }
  407.     else
  408.     { 
  409.         A=atom(A0); 
  410.         if(WARNFLAG && clause(A)==nil_clause) 
  411.         {       
  412.             ws("WARNING: no clause for relation "); 
  413.             wq(A); ws("/"); wi(arity(A));
  414.         }
  415.         A=copyatom(A);  
  416.         if(!spy(A) && SPYMODE) SPYING++;
  417.         if(spy(A) && !SPYMODE) SPYING--;
  418.         if(SPYMODE) setspy(A); else setnotspy(A);
  419.     }
  420.     set_spytrace();
  421. }
  422.  
  423.  
  424. GLOBAL boolean DOEQUAL(register TERM X0, register TERM X1, 
  425.                        REGISTER int DEPTH)
  426. {   register int i,aar;
  427.     register ATOM A;
  428.  
  429.     if(DEPTH <=0) ABORT(DEPTHE);
  430.     deref(X0); deref(X1);
  431.     if((A=name(X1))!=name(X0)) return false;
  432.     if(A==INTT) return ival(X0)==ival(X1);
  433.     if(A==UNBOUNDT) return X0==X1;
  434.     aar=arity(A); 
  435.     for(i=0,X1=son(X1),X0=son(X0);i<aar;i++,next_br(X1),next_br(X0))
  436.       if(! DOEQUAL(X0,X1,DEPTH-1)) return false;
  437.     return true;
  438. }
  439.  
  440. GLOBAL boolean ground(register TERM ARG, register int DEPTH)
  441. {   register int aar;
  442.     register ATOM A;
  443.     deref(ARG);
  444.     if(DEPTH <=0) ABORT(DEPTHE);
  445.     if((A=name(ARG))==UNBOUNDT) return false;
  446.     if(A<NORMATOM)  return true;
  447.     aar=arity(A);
  448.     ARG=son(ARG);
  449.     while(aar-- > 0)
  450.     {
  451.         if(! ground(ARG,DEPTH-1)) return false;
  452.         next_br(ARG);
  453.     }
  454.     return true;
  455. }
  456.  
  457. LOCAL boolean DOUNIV(void)
  458. {
  459.     ATOM A;
  460.     TERM X,Y,T;
  461.     int ARITY;
  462.     A=name(A0); 
  463.     if(A==UNBOUNDT)
  464.        {  for(T=A1,ARITY= -1; name(T)==CONS_2; ARITY++) T=arg2(T); 
  465.           if(name(T)!=NIL_0 || ARITY<0) ARGERROR();
  466.           if(ARITY==0) return UNI(A0,son(A1));
  467.           T=arg1(A1);
  468.           CHECKATOM(T);
  469.           Y=mkfunc(LOOKATOM(name(T),ARITY),stackterms(ARITY));
  470.           X=son(Y); T=arg2(A1);
  471.           while(ARITY--> 0)
  472.            { name(X)=UNBOUNDT; UNI(X,son(T));next_br(X); T=arg2(T); }
  473.           return UNI(Y,A0);
  474.        }
  475.     if(A<NORMATOM)
  476.       return UNI(A1,mkfunc(CONS_2,mk2sons(A,son(A0),NIL_0,nil_term)));
  477.     /* default */ 
  478.     X=Y=mkfunc(CONS_2,mk2sons(LOOKATOM(A,0),nil_term,NIL_0,nil_term));
  479.     ARITY=arity(A);
  480.     T=son(A0);
  481.     while(ARITY-->0)
  482.        { Y=br(son(Y)); 
  483.          name(Y)=CONS_2; son(Y)=mk2sons(UNBOUNDT,nil_term,NIL_0,nil_term);
  484.          UNI(son(Y),T);
  485.          next_br(T);
  486.        }
  487.     return UNI(X,A1);
  488. }  /* univ */
  489.  
  490. LOCAL boolean DOSORT(boolean delete)
  491. {
  492.     register TERM T,TT,S;
  493.     REGISTER TERM Res;
  494.     register int c;
  495.     if(!islist(A0,false)) ARGERROR();
  496.     Res=mkatom(NIL_0);
  497.     S=A0;
  498.     while(name(S)==CONS_2)
  499.     {   /* insert arg1(S) */
  500.         T=arg1(S);S=arg2(S);
  501.         TT=Res; c=1; /* set c to a value !=0 ! */
  502.         while(name(TT)==CONS_2 && (c=compare(arg1(TT),T,MAXDEPTH)) < 0)
  503.             TT=arg2(TT);
  504.         if(delete && c==0) continue;
  505.         /*
  506.         Temp=mk2sons(UNBOUNDT,nil_term,name(TT),son(TT));
  507.         name(TT)=CONS_2;
  508.         son(TT)=Temp;
  509.         UNI(Temp,T);
  510.         */
  511.         son(TT)=mk2sons(name(T),son(T),name(TT),son(TT));
  512.         name(TT)=CONS_2;
  513.     }
  514.     return UNI(A1,Res);
  515. }
  516.  
  517. /*
  518. **
  519. **  Flaghandling  on/off
  520. **
  521. */
  522.  
  523. LOCAL void SetFlag(boolean *FLAG)
  524. { ATOM A;
  525.   A=name(A0);
  526.   if(A==ON_0) *FLAG=true;
  527.   else if(A==OFF_0) *FLAG=false;
  528.     else if(A==UNBOUNDT)   
  529.               if(*FLAG)  UNI(A0,mkatom(ON_0));
  530.               else UNI(A0,mkatom(OFF_0));
  531.       else ARGERROR();
  532. }
  533.  
  534. LOCAL boolean DOCURATOM(boolean pred)
  535. /* current_predicate */
  536. {
  537.     ATOM A;
  538.     TERM T;
  539.     ENV NE,OC;
  540.  
  541.     OC=CHOICEPOINT;
  542.     if (!BCT) A=nil_atom; else A=(ATOM)BCT;
  543.     while(non_nil_atom(A=GetAtom(A)))
  544.     {
  545.         BCT=(int)A;
  546.         if(pred && (class(A) !=NORMP ||  clause(A)==nil_clause ||
  547.                      system(A))) continue;
  548.         NE=NEWENV(0);CHOICEPOINT=NE;
  549.         T=mk2sons(LOOKATOM(A,0),nil_term,INTT,(TERM)arity(A));
  550.         if(UNI(mkfunc(DIVIDE_2,T),A0))
  551.         { 
  552.             CHOICEPOINT=OC; return true; 
  553.         }
  554.         KILLSTACKS(NE);
  555.     }
  556.     return false;
  557. }
  558.  
  559.  
  560. LOCAL boolean DOCUROP(void)
  561. {
  562.     ATOM A,P;
  563.     ENV NE,OC;
  564.  
  565.     OC=CHOICEPOINT;
  566.     if (!BCT) A=nil_atom; else A=(ATOM)BCT;
  567.     while(non_nil_atom(A=GetAtom(A)))
  568.     {
  569.         switch(oclass(A))
  570.         {
  571.             case XFO:   P=XF_0;  break;
  572.             case FXO:   P=FX_0;  break;
  573.             case XFXO:  P=XFX_0; break;
  574.             case YFO:   P=YF_0;  break;
  575.             case FYO:   P=FY_0;  break;
  576.             case XFYO:  P=XFY_0; break;
  577.             case YFXO:  P=YFX_0; break;
  578.             default:    continue;
  579.         }
  580.         BCT=(int)A;
  581.         NE=NEWENV(0);CHOICEPOINT=NE;
  582.         if(   UNI(A0,mkint(oprec(A))) &&
  583.               UNI(A1,mkatom(P))   &&
  584.               UNI(A2,mkatom(LOOKATOM(A,0)))
  585.           )
  586.         { CHOICEPOINT=OC; return true; }
  587.         KILLSTACKS(NE);
  588.     }
  589.     return false;
  590. }
  591.  
  592. LOCAL void copy(register char *s)
  593. {
  594.     while(*s)
  595.         ATOMCHAR(*s++);
  596.     ATOMCHAR(' ');
  597. }
  598.  
  599. #if !CPM
  600. LOCAL boolean DOSYSTEM(void)
  601. {
  602.     TERM T;
  603.     ATOM A;
  604.  
  605.     STARTATOM(); /* init NEWATOM */
  606.     while(name(A0)==CONS_2)
  607.     {
  608.         T=arg1(A0); A=name(T); A0=arg2(A0);
  609.         if(A==INTT) copy(itoa(ival(T)));
  610. #if LONGARITH
  611.         else if(A==LONGT) copy(ltoa(longval(T)));
  612. #endif
  613. #if REALARITH
  614.         else if(A==REALT) copy(ftoa(realval(T)));
  615. #endif
  616.         else { CHECKATOM(T); copy(tempcopy(name(T))); }
  617.     }
  618.     TESTATOM(NIL_0,A0);
  619.     ATOMCHAR('\0'); /* terminate NEWATOM */
  620.     return call_system(NEWATOM);
  621. }
  622. #endif
  623.     
  624. boolean setval(int *x)
  625. {
  626.     if(name(A0)==UNBOUNDT) return INTRES(A0,*x);
  627.     if(name(A0)==INTT){*x=ival(A0); return true;}
  628.     ARGERROR();
  629.  
  630. }
  631.  
  632. LOCAL void copy_error_label(int *from, int *to)
  633. {   int size=sizeof(jmp_buf)/sizeof(int); 
  634.     while(size-- > 0) *to++= *from++;
  635. }
  636.  
  637.  
  638. TERM CALLX;
  639. ENV CALLXENV;
  640.  
  641. void CALLEVALPRED (TERM X, ENV ENVP)
  642. { 
  643.     ATOM NAME;
  644.     int  A;
  645.     auto jmp_buf old_error_label;
  646.     CALLX=X; CALLXENV=ENVP;
  647.     RES=true;
  648.     copy_error_label(error_label,old_error_label);
  649.     setjmp(error_label);
  650.     if(ERRORFLAG) { RES=false; goto exit; }
  651.  
  652.     E=ENVP; BE=base(ENVP);
  653.     deref(X);
  654.     NAME=name(X);
  655.     A=arity(NAME); 
  656.     X=son(X);
  657.     if(1<=A) 
  658.     { A0=X; deref(A0); next_br(X); 
  659.       if(2<=A) 
  660.       { A1=X; deref(A1); next_br(X); 
  661.         if(3<=A) 
  662.         { A2=X; deref(A2); next_br(X); 
  663.           if(4<=A) 
  664.           { A3=X; deref(A3);  
  665.             if (4<A) SYSTEMERROR("CALLEVALPRED.0");
  666.           }
  667.         }
  668.       }
  669.     }
  670.  
  671.     switch (NAME) 
  672.     { 
  673. #if !CPM
  674.     /* date/time handling */
  675.     case TIME_3:        
  676.     case DATE_3:       
  677.     case WEEKDAY_1:     RES=DOTIME(NAME); break;
  678.     case TIMER_1:       RES=DOTIMER(); break;
  679. #endif
  680.  
  681.     /* input/output predicates */
  682.     case OP_3:           DOOP();break;
  683.  
  684.     case READ_1:        RES=UNI(READIN(),A0); break;
  685.     case READ_2:        RES=DOREAD();break;
  686.     case WRITE_1:       WRITEOUT(A0,false); break;
  687.     case WRITEQ_1:      WRITEOUT(A0,true); break;
  688.     case DISPLAY_1:     DISPLAY(A0);break;
  689.     case GET0_1:        RES=DOGET0();break;
  690.     case GET_1:         RES=DOGET();break;
  691.     case UNGET_0:       REGET();break;
  692.     case SKIP_1:        DOSKIP();break;
  693.     case PUT_1:         DOPUT();break;
  694.     case CLS_0:         DOCLS(); break;
  695.     case NL_0:          ws("\n"); break;
  696.     case TAB_1:         DOTAB();break;
  697.     case GOTOXY_2:      DOGOTOXY(); break; 
  698.     case ASK_1:         RES=DOASK();break;
  699.  
  700.     case TTYREAD_1:    
  701.     case TTYGET0_1:   
  702.     case TTYGET_1:   
  703.     case TTYSKIP_1: 
  704.     case TTYASK_1:      setinfile();
  705.                         switch(NAME)
  706.                         {
  707.                           case TTYREAD_1:  RES=UNI(READIN(),A0); break;
  708.                           case TTYGET0_1:  RES=DOGET0();break;
  709.                           case TTYGET_1:   RES=DOGET();break;
  710.                           case TTYSKIP_1:  DOSKIP();break;
  711.                           case TTYASK_1:   RES=DOASK();break;
  712.                         }
  713.                         getinfile();
  714.                         break;
  715.     case TTYWRITE_1:    
  716.     case TTYPUT_1:     
  717.     case TTYCLS_0:    
  718.     case TTYNL_0:    
  719.     case TTYTAB_1:  
  720.     case TTYGOTOXY_2:   setoutfile();
  721.                         switch(NAME)
  722.                         {
  723.                           case TTYWRITE_1:  WRITEOUT(A0,false); break;
  724.                           case TTYPUT_1:    DOPUT();break;
  725.                           case TTYCLS_0:    DOCLS(); break;
  726.                           case TTYNL_0:     ws("\n"); break;
  727.                           case TTYTAB_1:    DOTAB();break;
  728.                           case TTYGOTOXY_2: DOGOTOXY(); break; 
  729.                         }
  730.                         getoutfile();
  731.                         break;
  732.  
  733.     case EOLN_0:        RES=LINEENDED(); break;
  734.     case EOF_0:         RES=FILEENDED(); break;
  735.     case SEE_1:         RES=DOSEE();break;
  736.     case SEEING_1:      RES=UNI(A0,mkatom(FLOGNAME(inputfile))); break;
  737.     case SEEN_0:        RES=DOSEEN();break;
  738.                         /* CloseFile(inputfile);A0=mkatom(USER_0);
  739.                         RES=DOSEE();break; */
  740.     case TELL_1:        RES=DOTELL();break;
  741.     case TELLING_1:     RES=UNI(A0,mkatom(FLOGNAME(outputfile))); break;
  742.     case TOLD_0:        CloseFile(outputfile);A0=mkatom(USER_0);
  743.                         RES=DOTELL();break;
  744.     case OPEN_1:        RES=DOOPEN();break;
  745.     case CLOSE_1:       RES=DOCLOSE();break;
  746. #if !CPM
  747.     case SEEK_2:        RES=DOSEEK();break;
  748. #endif
  749.     case WGET0_1:       
  750. #if WINDOWS
  751.                         if(xWINDOW_ON) RES=INTRES(A0,t_rc());
  752.                         else 
  753. #endif
  754.                         RES=DOGET0(); break;
  755.     case aWINDOW_0:     RES=xWINDOW_ON;break;
  756.     case FILEE_0:       FERRORFLAG=true;break;
  757.     case NFILEE_0:      FERRORFLAG=false;break;
  758. #ifdef ARCHY
  759.     case SYNCLOSE_0:    SYNCLFLAG=true; break;
  760.     case NSYNCLOSE_0:   SYNCLFLAG=false;break;
  761. #endif
  762.     case FILEE_1:       SetFlag(&FERRORFLAG);break;
  763.     case CONSULT_1:     RES=DOCONSULT(false);break;
  764.     case RECONSULT_1:   RES=DOCONSULT(true);break;
  765.  
  766.     case FASSIGN_2:     RES=DOFASSIGN();break;
  767. #if !CPM
  768.     case SYSTEM_1:      RES=DOSYSTEM();break;
  769. #endif
  770.     case ARGC_1:        RES=INTRES(A0,ARGC);break;
  771.     case ARGV_2:        {
  772.                             int i;
  773.                             if((i=INTVALUE(A1))<0 || i >=ARGC) 
  774.                                 ERROR(ARGE);
  775.                             RES=UNI(A0,mkatom(LOOKUP(ARGV[i],0,false)));
  776.                         }
  777.                         break;
  778. #if UNIX
  779.     case OPSYS_1:       RES=UNI(A0,mkatom(LOOKUP("unix",0,false))); break;
  780. #endif
  781. #if RISCOS
  782.     case OPSYS_1:       RES=UNI(A0,mkatom(LOOKUP("riscos",0,false))); break;
  783. #endif
  784. #if MS_DOS
  785.     case OPSYS_1:       RES=UNI(A0,mkatom(LOOKUP("msdos",0,false))); break;
  786. #endif
  787. #if CPM
  788.     case OPSYS_1:       RES=UNI(A0,mkatom(LOOKUP("cpm",0,false))); break;
  789. #endif
  790. #if VMS
  791.     case OPSYS_1:       RES=UNI(A0,mkatom(LOOKUP("vms",0,false))); break;
  792. #endif
  793.     case RESTART_0:     ABORT(NOERROR);break;
  794.     case ABORT_0:       ABORT(ABORTE); break;
  795.     case END_0:         HALTFLAG=true; break;
  796.     case TRACE_1:       SetFlag(&TRACING);set_spytrace();TRACE_GOON=0;
  797.                         break;
  798.     case TRACE_0:       TRACING=true; set_spytrace();TRACE_GOON=0;
  799.                             break;
  800.     case NOTRACE_0:     TRACING=false; set_spytrace();TRACE_GOON=0;
  801.                         break;
  802.     case SPY_1:         DOSPY(true); TRACE_GOON=0; break;
  803.     case NOSPY_1:       DOSPY(false); TRACE_GOON=0;
  804.                         break;
  805.     case ECHO_1:        SetFlag(&ECHOFLAG); break;
  806.     case DEBUG_1:       SetFlag(&DEBUGFLAG); break;
  807.     case STATS_0:       DOSTATS(); break;
  808.     case aINTERRUPT_1:  SetFlag(&ENAB_INTR);
  809.                         if(ENAB_INTR && UserAbort)EVENT=true;
  810.                         break;
  811.     case SYSMODE_1:     SetFlag(&aSYSMODE);break;
  812.     case REDUCE_1:      SetFlag(&REDUCEFLAG);break;
  813. #if OCCUR_CHECK
  814.     case OCHECK_1:      SetFlag(&OCHECK);break;
  815. #endif
  816.     case WARN_1:        SetFlag(&WARNFLAG);break;
  817.     case EXIT_1:        RETURN_CODE=INTVALUE(A0);
  818.     case HALT_0:        LONG_JMP(999);break;
  819.     case SAVE_1:        DOSAVE();break;
  820.  
  821.     /* term manipulation */
  822.     case LIST_1:        RES=islist(A0,false);break;
  823.     case STRING_1:      RES=islist(A0,true);break;
  824.     case COMPOUND_1:    RES=name(A0) > NORMATOM && arity(name(A0));
  825.                             break;
  826. #if REALARITH
  827.     case REAL_1:        RES=name(A0)==REALT;break;
  828. #endif
  829.     case NUMBER_1:      RES=is_number(name(A0));break;
  830.     case ATOMIC_1:      RES=isatom(A0) || is_number(name(A0));break;
  831.     case NONVAR_1:      RES=name(A0)!=UNBOUNDT; break;
  832.     case SYS_1:         RES=system(atom(A0));break;
  833.     case CURATOM_1:     RES=DOCURATOM( false );break;
  834.     case CURPRED_1:     RES=DOCURATOM( true );break;
  835.     case CUROP_3:       RES=DOCUROP();break;
  836.     case NAME_2:        RES=DONAME();  break;
  837.     case FUNCTOR_3:     RES=DOFUNCTOR();  break;
  838.     case ARG_3:         RES=DOARG();  break;
  839.     case UNIV_2:        RES=DOUNIV();break;
  840.     case MEMBER_2:      RES=DOMEMBER(); break;
  841.     case APP_3:         RES=DOAPPEND(); break;
  842.     case SORT_2:        RES=DOSORT(false);break;
  843.     case SORT0_2:       RES=DOSORT(true);break;
  844.     case EQUAL_2:       RES=DOEQUAL(A0,A1,MAXDEPTH);break;
  845.     case NOEQUAL_2:     RES= !DOEQUAL(A0,A1,MAXDEPTH);break;
  846.     case INVAR_1:       RES= !ground(A0,MAXDEPTH);break;
  847.     case GROUND_1:      RES=ground(A0,MAXDEPTH);break;
  848.     case ALT_2:         RES=compare(A0,A1,MAXDEPTH)<0;break;
  849.     case ALE_2:         RES=compare(A0,A1,MAXDEPTH)<=0;break;
  850.     case AGT_2:         RES=compare(A0,A1,MAXDEPTH)>0;break;
  851.     case AGE_2:         RES=compare(A0,A1,MAXDEPTH)>=0;break;
  852.     case AEQ_2:         RES=compare(A0,A1,MAXDEPTH)==0;break;
  853.     case ANE_2:         RES=compare(A0,A1,MAXDEPTH)!=0;break;
  854.  
  855.     /* arithmetic operations, see arith.c */
  856.     case IS_2:          RES=DOIS(A0,A1);break;
  857.     case ACOMP_1:       RES=DOACOMP();break;
  858.     case DASSIGN_2:     RES=DODASS();break;
  859.     case REDUCE_2:      DOREDUCE(A0,A1,false); break; 
  860.  
  861.     /* database operations */
  862.     case DICT_1:        RES=DODICT(false); break;
  863.     case SDICT_1:       RES=DODICT(true); break;
  864.  
  865.     case ASSERTA_1:     DOASSA();break;
  866.     case ARROW_2:       A0=mkfunc(ARROW_2,
  867.                                     mk2sons(name(A0),son(A0), name(A1),son(A1)));
  868.     case ASSERT_1:
  869.     case ASSERTZ_1:     A2=mkatom(END_0);
  870.                         DOASSERT(false);break;
  871.     case DBASS_2:
  872.     case DBASSZ_2:      A2=mkatom(END_0);
  873.                         DOASSERT(true);break;
  874.     case DBASSA_2:      A2=mkint(0);
  875.                         /* no break */
  876.     case DBASS_3:       DOASSERT(true);break;
  877.     case LISTALL_0:     A0=mkatom(ALL_0);/* no break */
  878.     case LISTING_1:     DOLISTING(); break;
  879.     case CLAUSE_2:      RES=DOCLAUSE(false);break;
  880.     case CLAUSE_3:      RES=DOCLAUSE(true);break;
  881.     case RETRACT_1:     RES=DORETRACT(false,false);break;
  882.     case DBRET_2:       RES=DORETRACT(true,false);break;
  883.     case RETALL_1:      RES=DORETRACT(false,true);break; 
  884.     case ABOL_1:        DOABOLISH(1);break;
  885.     case ABOL_2:        DOABOLISH(2);break;
  886.     case VERSION_0:     DOVERSION(); break;
  887.     case PRIVATE_1:     DOPRIVATE();break;
  888.     case HIDE_1:        DOHIDE();break;
  889.     case ANCESTORS_1:   RES=DOANCESTORS();break;
  890.     case ENSURE_3:      RES=DOENSURE();break;
  891.  
  892. #if !CPM
  893.     case GETENV_2:      RES=DOGETENV();break;
  894. #if !P8000 && !RISCOS
  895.     case PUTENV_2:      DOPUTENV();break;
  896. #endif
  897. #endif
  898.  
  899. #if HELP
  900.     case HELP_0:        DOHELP(nil_term);break;
  901.     case HELP_1:        DOHELP(A0);break;
  902. #endif
  903.  
  904. #if DBASE3
  905.     case OPENDBF_2:     RES=DOOPENDBF(A0,A1);break;
  906.     case CLOSEDBF_1:    RES=DOCLOSEDBF(A0);break;
  907.     case READDBF_3:     RES=DOREADDBF(A0,A1,A2);break;
  908.     case WRITEDBF_3:    RES=DOWRITEDBF(A0,A1,A2);break;
  909.     case SEEKDBF_2:     RES=DOSEEKDBF(A0,A1);break;
  910.     case ERASEDBF_2:    RES=DOERASEDBF(A0,A1);break;
  911. #endif
  912.  
  913. #if HACKY
  914.     case iCHOICEP_1:    RES=setval(&CHOICEPOINT);break;
  915.     case iSTACKT_1:     RES=setval(&GLOTOP);break;
  916.     case iHEAPT_1:      RES=setval(&HEAPTOP);break;
  917.     case iASTACKT_1:    RES=setval(&ATOMSTOP);break;
  918.     case iAHEAPT_1:     RES=setval(&ATOMHTOP);break;
  919.     case iENV_1:        RES=setval(&ENVTOP);break;
  920.     case iTRAIL_1:      RES=setval(&TRAILEND);break;
  921.     case iNROFCALLS_2:  RES=INTRES(A0,nrofcalls(atom(A1)));break;
  922. #endif
  923.  
  924. #if SYMBOLARITH
  925.     case SUBST_4:       RES=UNI(A0,SUBSTITUTION(A1,A2,A3)); break;
  926. #endif
  927.  
  928. #if CPM
  929.     case BDOS_3:        RES=INTRES(A2,
  930.                          bdos(INTVALUE(A0),INTVALUE(A1))); break;
  931. #endif
  932.  
  933. #if CPM || HACKY
  934.     case PEEK_3:        RES=DOPEEK(); break;
  935.     case POKE_2:        RES=DOPOKE(); break;
  936. #endif
  937.  
  938.     default:             
  939. #if USER
  940.           RES=CallUser(CALLX);break;
  941. #endif
  942. #if !USER
  943.           ws("\007sorry, this predicate is reserved, ");
  944.           ws("but not yet implemented\n");
  945.           ERROR(CALLE);
  946. #endif
  947.   }
  948.   CALLX=nil_term;
  949. exit:
  950.   copy_error_label(old_error_label,error_label);
  951.   return;
  952.  
  953. }
  954.  
  955.  
  956.